;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; This file is part of ICCLE2.
;
; ICCLE2 is free software: you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation, either version 3 of the License, or
; (at your option) any later version.
;
; ICCLE2 is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.
;
; You should have received a copy of the GNU General Public License
; along with ICCLE2.  If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *best* nil)
(defparameter *ctr* 0)


(defun nomo (&key (source #'titanic)  (action #'nomogram) (n 1) goal)
  (setf *best* nil)
  (dolist (tbl (data (funcall source) :n n))
    (nomo1 tbl action goal))
  *best*) 

(defun nomo1 (tbl action goal)
  (let  ((klassh (klassh tbl)))
    (dotimes (klass (discrete-cardinality klassh))
      (if (or t (not goal)
	      (and goal (eql goal (sym->thing klassh klass))))
	  (nomo2 tbl klassh klass (+ (adash)
				     (f1 tbl klass)) action)))))

(defun nomo2 (tbl klassh klass1 h1 action)
  (let ((us   (make-hash-table :test #'equal))
        (them (make-hash-table :test #'equal))
        lors
        (h2 (adash)))
    (dotimes (klass2 (discrete-cardinality klassh))
      (setf *ctr* 0)
      (when (/= klass2 klass1)
        (incf h2 (f1 tbl klass2))
        (doarray (colh col (table-headers tbl))
          (unless (eq colh klassh)
            (dotimes (val (discrete-cardinality colh))
              (let ((key   (cons col val))
                    (us1   (f3 tbl klass1 col val))
                    (them1 (f3 tbl klass2 col val))
                    )     
                (setf (gethash key us    ) us1)
                (incf (gethash key them 0) them1)
                ))))))
    (print 2)
    (dohash (key n1 us)
      (let* ((n2    (gethash key them))
             (lor   (log (/ (+ (adash) (/ n1 h1)) 
			    (+ (adash) (/ n2 h2))))))
        (push (list lor key (name1 tbl key)) lors)))
    (setf lors (sort lors #'> :key #'first))
    (print 1)
    (funcall action  
             (sym->thing klassh klass1)
             (/ h1 (table-rows tbl))
             lors)))     

(defun name1 (tbl key)
  (let* ((col (first key))
        (colh (aref (table-headers tbl) col))
        (val (rest key)))
    (list (discrete-name colh)
          (sym->thing colh val))))

(defun  points2p (f p) 
  (let* ((l    (log (/ p (- 1 p))))
         (negl (* -1 l))
         (exp 0)
	 (val 0))
    (handler-case
	(progn
	  (setf exp (- negl f)))
      (floating-point-overflow ()
	(setf exp most-positive-fixnum)))
    (handler-case
	(progn
	  (setf val (expt e exp)))
      (floating-point-overflow ()
	(setf val most-positive-fixnum)))
    (/ 1 (+ 1 val))))

(defun nomogram (klass p lors &optional (width 40))
  (let* ((least (first (last1 lors)))
        (most   (first (first lors)))
        (growth (/ (- most least) width)))
    (format t "~%~a~%C = ~a ~%" (nchars 80 #\_) klass)
    (nomogram0 "attr" "range" "lor " "P(C)" "P(C)+" "used")
    (nomogram0 "____" "_____" "____" "____" "_____" "____")
    (nomogram1 (first lors) (rest lors) p least most growth 0)))

(defun nomogram0 (attr range lor pc pcs used)
  (let ((line (nchars 94)))
    (setf (subseq line  0 24) (format nil "~10@A   ~10a" attr range))
    (setf (subseq line 88 93) (format nil " ~4@A" used))
    (setf (subseq line 81 87) (format nil " ~4@A" pcs))
    (setf (subseq line 75 80) (format nil " ~4@A" pc))
    (setf (subseq line 68 74) (format nil " ~5@A" lor))
    (format t "~a~%" line)))

(defun nomogram1 (head tail p  least most growth n &optional used (before 0))
  (labels ((n (x) (+ 25 (floor (/ x growth)))))
    (let* ((lor   (first head))
	   (lor1  (+ before lor))
           (attr  (first (third head)))
           (value (second (third head)))
           (line  (nchars 100))
           (pc    (points2p lor p))
	   (pc1   (points2p lor1 p))
	   after  
	   (usedp "")
           mark start  offset )
     (setf after lor1)
     
     (when (zerop n) (setf usedp t)
	   (push attr used))
     (unless (or (member attr used :test #'equalp) 
                 (< lor 0)
		 (<= 0.995 pc1 1)
	         (< pc1 (* 1.05 pc)))
       (push attr used)
       (setf usedp t))
     (setf (subseq line  0 24) (format nil "~10@A = ~10a" attr value))
     (setf (subseq line 81 87) (format nil " ~4,2f"  pc1))
     (setf (subseq line 88 100) (format nil " ~4@A"  usedp))
     (setf (subseq line 75 80) (format nil " ~4,2f" pc))
     (setf (subseq line 68 74) (format nil " ~5,2f" lor))
     (if (< lor 0)
	 (setf start (- lor least) offset (- lor) mark #\-)
	 (setf start (- least)     offset lor     mark #\+))
     (setf (subseq line (n start) (n (+ start offset)))
	   (nchars  (n offset) mark))
     (format t "~a~%" line)
     (if (= 0 *ctr*)
         (setf *best* (append *best* (list (list attr value)))))
     (setf *ctr* 1) 
     (if tail
	 (nomogram1 (first tail) (rest tail) 
		    p least most growth (1+ n) used after)))))
 
